home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / syntx-utl.em < prev    next >
Encoding:
Text File  |  1993-07-12  |  10.6 KB  |  377 lines
  1. ;; Eulisp Module
  2. ;; Author: pete broadbery
  3. ;; File: syntax-utils.em
  4. ;; Date: 15/sep/1991
  5. ;;
  6. ;; Project: Compiler
  7. ;; Description: 
  8. ;;   General utils related to ast's
  9. ;;  Guesses type of fn. calls.
  10.  
  11. (defmodule syntx-utl 
  12.   ((except (fold) standard)
  13.    list-fns
  14.    
  15.    syntx-env
  16.    pass
  17.    props
  18.  
  19.    stop
  20.    )
  21.   ()
  22.   
  23.   (expose syntx-env)
  24.  
  25.   (defun find-decls (defn)
  26.     (cond ((module-definition-p defn)
  27.        nil)
  28.       ((definition-p defn) 
  29.        (list defn))
  30.       ((and-decl-p defn)
  31.        (fold append
  32.          (mapcar find-decls
  33.              (and-decl-decls defn))
  34.          nil))
  35.       ((rec-decl-p defn)
  36.        (find-decls (rec-decl-decl defn)))))
  37.   
  38.   (export find-decls)
  39.  
  40.   (defgeneric get-internal-closed-bindings (obj))
  41.  
  42.   (defmethod get-internal-closed-bindings ((x syntax-obj))
  43.     (fold append
  44.       (mapcar get-internal-closed-bindings (subcomponents x))
  45.       nil))
  46.  
  47.   (defmethod get-internal-closed-bindings ((x definition))
  48.     (if (binding-closed x) 
  49.     (cons x (call-next-method))
  50.       (call-next-method)))
  51.  
  52.   (defmethod get-internal-closed-bindings ((x lambda-term))
  53.     ;; XXX Not if its inline...
  54.     nil)
  55.  
  56.   ;; finds the innermost non-tail posn lambda
  57.   
  58.   (defun get-enclosing-object (fn start)
  59.     (get-enclose-aux fn (enclosing-block start)))
  60.  
  61.   (defun get-enclose-aux (fn obj)
  62.     (if (fn obj)
  63.     obj
  64.       (get-enclose-aux fn (enclosing-block obj))))
  65.  
  66.   (defun enclosing-lambda (obj)
  67.     (get-enclosing-object is-real-lambda obj))
  68.  
  69.   (defgeneric is-real-lambda (obj)
  70.     methods ((((x lambda-term))
  71.           t)
  72.          (((x module-block))
  73.           t)
  74.          (((x <object>))
  75.           nil)))
  76.  
  77.   (defun enclosing-module (x)
  78.     (get-enclosing-object module-p x))
  79.   
  80.   (export get-internal-closed-bindings enclosing-lambda)
  81.  
  82.   (defun function-fn (lst)
  83.     (cdr (assq 'object lst)))
  84.   
  85.   (defun function-type (lst)
  86.     (cdr (assq 'class lst)))
  87.  
  88.   (defun function-prop (lst x)
  89.     (cdr (assq x lst)))
  90.  
  91.   ;; if we dont know, pretend we do+that it will be sorted out later.
  92.   (defun function-nargs (lst)
  93.     (let ((type (assq 'argtype lst)))
  94.       (if (null type) (cons () 9999)
  95.     (cond ((consp (cdr type))
  96.            (car (cdr type)))
  97.           (t (cons (< (cdr type) 0) 
  98.                (if (< (cdr type) 0) (- (cdr type)) (cdr type))))))))
  99.  
  100.   (defun function-nary-p (obj) 
  101.     nil)
  102.  
  103.   ;; If at all possible, find the function object referenced by obj. 
  104.   ;; Guessing what a function is.
  105.   
  106.   (defgeneric find-fn (x)
  107.     methods ((((x syntax-obj))
  108.           (cons (cons 'object x) (unknown-object-properties)))
  109.          (((x ident-term))
  110.           (let ((props
  111.              (cons (cons 'object (ident-decl x)) (read-defn-properties (ident-decl x)))))
  112.         (if (eq (function-type props) 'bytefunction)
  113.             (cond ((module-definition-p (ident-decl x))
  114.                (cons (cons 'class 'local) props))
  115.               ((definition-p (ident-decl x))
  116.                (cons (cons 'class 'lexical) props))
  117.               (t props))
  118.           props)))
  119.          (((x lambda-id))
  120.           (cons (cons 'object x) (unknown-object-properties)))
  121.          (((x special-term))
  122.           (compute-special-proplist x))
  123.          (((x abs-definition))
  124.           (read-defn-properties x))
  125.          (((x applic-term))
  126.           (let ((xx (compute-compile-time-proplist x)))
  127.         (if (null xx)
  128.             (cons (cons 'object x) (unknown-object-properties))
  129.           (progn (format t "Inlining ~a~%" (cdar xx))
  130.              xx))))
  131.          (((x <object>))
  132.           (format t "Unknown object: ~a~%" x)
  133.           (error "dunno" <clock-tick>))
  134.          ))
  135.   
  136.   (export function-fn function-type function-nargs function-nary-p find-fn function-prop)
  137.  
  138.   ;; accessing an objects property list...
  139.  
  140.   (defun unknown-object-properties ()
  141.     '((class . unknown) (mutable nil)))
  142.  
  143.   (defgeneric read-defn-properties (defn)
  144.     methods ((((defn imported-definition))
  145.           (defn-properties defn))
  146.          (((defn local-definition))
  147.           (if (decl-done-properties defn)
  148.           (defn-properties defn)
  149.         (let ((props (compute-properties defn)))
  150.           ((setter decl-done-properties) defn t)
  151.           ((setter defn-properties) defn 
  152.            (append props (defn-properties defn)))
  153.           props)))
  154.          (((defn lambda-id))
  155.           (unknown-object-properties))
  156.          (((defn <object>))
  157.           (error "no way" <clock-tick>))))
  158.  
  159.   ;; Calculate the property list for a binding
  160.   (defgeneric compute-properties (defn))
  161.   
  162.   (defmethod compute-properties ((defn local-definition))
  163.     (if (binding-mutable defn) 
  164.     (list (list 'mutable t) 
  165.           (list 'class 'unknown))
  166.       (cons (list 'mutable nil)
  167.         (classify (defn-body defn)))))
  168.   
  169.   (defmethod compute-properties ((defn module-definition))
  170.     (let ((lst (call-next-method)))
  171.       (append (list (list 'address (module-name (enclosing-module defn)) (defn-ide defn)))
  172.           (append (list (cons 'name (defn-ide defn)))
  173.               lst))))
  174.  
  175.   (defun compute-special-proplist (special)
  176.     (generic-classify special))
  177.   
  178.   
  179.   ;; Real analysis: Find the type of a declaration.
  180.   ;; Returns a-list --- keys: mutable, class (bytefunction, bytemacro, internal, 
  181.   ;;                  function --- 'C', object), argtype, 
  182.   
  183.   (defun classify (obj)
  184.     (generic-classify obj))
  185.  
  186.   (defgeneric generic-classify (body))
  187.   
  188.   (defmethod generic-classify ((lam lambda-term))
  189.     (list (cons 'class 'bytefunction)
  190.       (list 'argtype (lambda-nargs lam))))
  191.  
  192.   (defmethod generic-classify ((mlam macro-lambda-term))
  193.     (list (cons 'class 'macro)
  194.       (list 'argtype (lambda-nargs mlam))))
  195.  
  196.   (defmethod generic-classify ((x term))
  197.     (list (cons 'class 'unknown)))
  198.  
  199.   (defmethod generic-classify ((x special-term))
  200.     (cond ((eq (special-term-name x) 'inline-fn)
  201.        (list (cons 'class 'inline)
  202.          (cons 'argtype (car (special-term-data x)))
  203.          (cons 'code (cdr (special-term-data x)))))
  204.       ((eq (special-term-name x) 'call-next-method-internal)
  205.        (list (cons 'object x) (cons 'class 'special)))
  206.       (t (cons 'class 'unknown))))
  207.     
  208.   (defun decl-class (x)
  209.     (let ((props (read-defn-properties x))
  210.       (setter (decl-setter x)))
  211.       (if (null setter)
  212.       props
  213.     (append props 
  214.         (list (cons 'setter (read-defn-properties setter)))))))
  215.  
  216. ;;    (let ((xx (decl-class-uncached x)))
  217. ;;      (if (null xx)
  218. ;;      (let ((aa (classify-decl x)))
  219. ;;        ((setter decl-class-uncached) x aa)
  220. ;;        aa)
  221. ;;    xx))
  222.  
  223.   (defun std-class-list (x)
  224.     ;; just the address at the moment...
  225.     (cons (cons 'name (defn-ide x))
  226.       (cons (list 'address (module-name (enclosing-module x)) (defn-ide x))
  227.         (let ((xx nil)) ;;; (obj-setter x)
  228.           (if (null xx)
  229.               nil
  230.             (list (cons 'setter (decl-class xx))))))))
  231.         
  232.   (export decl-class)
  233.  
  234.   ;; dependencies...
  235.   
  236.   (defun add-dependency (mod defn)
  237.     (if (memq (import-home defn) (module-dependencies mod))
  238.     nil
  239.       ((setter module-dependencies) mod
  240.        (cons (import-home defn) (module-dependencies mod)))))
  241.   
  242.   (export add-dependency)
  243.  
  244.  
  245.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  246.   
  247.   (defun compute-compile-time-proplist (x)
  248.     (let ((val (compute-compile-time-value x)))
  249.       (if (abs-definition-p val)
  250.       (cons (cons 'object val) (read-defn-properties val))
  251.     nil)))
  252.  
  253.   (defgeneric compute-compile-time-value (x))
  254.  
  255.   (defmethod compute-compile-time-value ((app applic-term))
  256.     (let ((fn (compile-time-value (applic-fun app)))
  257.       (args (applic-args app)))
  258.       (cond ((null fn) nil)
  259.         ((setter-function-p fn)
  260.          (find-setter (compile-time-value (car args))))
  261.         (t nil))))
  262.  
  263.   (defmethod compute-compile-time-value ((x ident-term))
  264.     (compute-compile-time-value (car (ident-defblock x))))
  265.  
  266.   (defmethod compute-compile-time-value ((x module-definition))
  267.     (if (binding-mutable x) nil x))
  268.  
  269.   (defmethod compute-compile-time-value ((x imported-definition))
  270.     x)
  271.  
  272.   (defmethod compute-compile-time-value ((x syntax-obj))
  273.     nil)
  274.  
  275.   ;; Generic --- could look at the property thang...
  276.   ;;
  277.   ;; nasty local-defn case cos of
  278.   ;; (let ((x (if foo a b)))
  279.   ;;   ((setter x) y))
  280.   (defgeneric find-setter (value)
  281.     methods ((((defn imported-definition))
  282.           (import-defn-setter defn))
  283.          (((defn local-definition))
  284.           (decl-setter defn))
  285.          (((o <object>))
  286.           nil)))
  287.  
  288.   (defun compile-time-value (x)
  289.     (let ((xx (cached-compile-time-value x)))
  290.       (cond ((null xx)
  291.          (let ((val (compute-compile-time-value x)))
  292.            ((setter cached-compile-time-value) x 
  293.         (if (null val) 'no-way val))
  294.            val))
  295.         ((eq xx 'no-way) nil)
  296.         (t xx))))
  297.   
  298.   ;; setting setter functions
  299.   
  300.   (defgeneric set-setter-function (fn new-setter)
  301.     methods ((((ident ident-term) new-setter)
  302.           (set-setter-function (ident-decl ident) new-setter))
  303.          ((thing (ide ident-term))
  304.            (set-setter-function thing (ident-decl ide)))
  305.          (((decl local-definition) (setter-decl module-definition))
  306.           (if (or (binding-mutable decl)
  307.               (binding-mutable setter-decl))
  308.           nil
  309.         ((setter decl-setter) decl setter-decl)))
  310.          (((decl imported-definition) (setter-decl module-definition))
  311.           (if (or (binding-mutable decl)
  312.               (binding-mutable setter-decl))
  313.           nil
  314.         (add-defn-prop decl 'setter (read-defn-properties setter-decl))))
  315.          (((o1 <object>) (o2 <object>))
  316.           nil)))
  317.   
  318.   (defun setter-function-p (x) 
  319.     (let ((aa (defn-prop-ref x 'setter-function)))
  320.       aa))
  321.     
  322.   ;; end module
  323.   )
  324.   (defgeneric find-fn (obj)
  325.     methods ((((x syntax-obj))
  326.           (list x 'unknown 0))
  327.          (((x applic-term))
  328.           (let ((xx (compile-time-value x)))
  329.         (if (null xx)
  330.             (list x 'unknown 0)
  331.           (find-fn xx))))
  332.          (((x lambda-term))
  333.           ;;(format t "Lambda: nargs: ~a~%" (lambda-nargs x))
  334.           (list x 'bytefunction (lambda-nargs x)))
  335.          (((x ident-term))
  336.           (let ((props (read-defn-properties (ident-decl x))))
  337.         (list (ident-decl x) 'unknown 0)))
  338.           ;;(let ((xx (find-fn (car (ident-defblock x)))))
  339.           ;;(if (and (eq (function-type xx) 'local-defun)
  340.           ;;(eq (car xx) (enclosing-lambda x)))
  341.           ;;(cons (car xx)
  342.           ;;(cons 'lexical
  343.           ;;(cddr xx)))
  344.           ;;xx))
  345.          (((x definition))
  346.           (if (defn-mutable-p x)
  347.           (list x 'unknown 0)
  348.         (let ((actual (find-fn (defn-body x))))
  349.           ;; try to env+call via a jump
  350.           (cond ((eq (function-type actual) 'bytefunction)
  351.              (cons (car actual) 
  352.                    (cons 'lexical ;; was local-defun
  353.                      (cddr actual))))
  354.             ((eq (function-type actual) 'special)
  355.              actual)
  356.             (t (list x 'unknown 0))))))
  357.          (((x module-definition))
  358.           (if (defn-mutable-p x) 
  359.           (list x 'unknown 0)
  360.         (let ((actual (find-fn (defn-body x))))
  361.           (cond ((eq (function-type actual) 'bytefunction)
  362.              (cons (car actual) 
  363.                    (cons 'local
  364.                      (cddr actual))))
  365.             ((eq (function-type actual) 'special)
  366.              actual)
  367.             (t (list x 'unknown 0))))))
  368.          (((x imported-definition))
  369.           ;; defined in syntax-utils
  370.           (list x (import-object-type x) 
  371.             (import-function-nargs x)))
  372.          (((x special-term))
  373.           (list x 'special 0))
  374.          (((x object))
  375.           ;;(format t "Find Fn Got Strange: ~a~%" x)
  376.           (stop x))))
  377.